home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
basic
/
qbclrsel.zip
/
CSELDEMO.BAS
next >
Wrap
BASIC Source File
|
1992-02-23
|
27KB
|
743 lines
'***************************************************************************
'QUICK BASIC COLOR SELECT SUBROUTINE
'***************************************************************************
'
'A configurable subroutine to generate a color selection display
'for text-mode (SCREEN 0) screens in your program, enabling the user
'to select desired combination of foreground and background colors
'for any text display of your program.
'
'Written by: Peter R. Barnes
' February, 1992
'
'This routine is released to the public domain. Feel free to modify it
'to suit your own individual style or requirements. I did not make
'any serious effort to compose the most efficient or elegant code to
'perform the task, but it does the job. Do with this what you will, just
'don't blame me for the results (unless they are great, of course).
'See the subroutine herein for documentation. Merely cut and paste
'to use the subroutine in your program, or delete the code in this main
'module of the demo and compile to a separate .OBJ file which you can
'then link to any program.
'
'If you use this code in a program which you offer for sale, please
'give credit where credit is due (namely, moi). A mention of my name
'in your program's documentation would suffice.
'
'NOTE THAT THIS ROUTINE DOES NOT CHECK THE STATUS OF THE BACKGROUND
'COLOR VIDEO DISPLAY MODE, WHICH CAN BE SET TO DISPLAY EITHER BLINKING
'BACKGROUND COLORS OR HIGH-INTENSITY BACKGROUND COLORS FOR ATTRIBUTES
'ABOVE 15; THE ROUTINE ASSUMES THE DEFAULT MODE, BLINKING, IS ENABLED.
'IF YOU WANT TO GUARANTEE ONE MODE OR THE OTHER EXISTS, YOU WILL HAVE
'TO USE Call Interrupt TO SET THE MODE VIA INTERRUPT 10, AX=&H1003,
'BL=0 FOR HIGH-INTENSITY, 1 FOR BLINKING. AND THAT ONLY WORKS FOR SOME
'COLOR ADAPTERS, SOMETIMES; THERE REALLY IS NO SURE-FIRE WAY TO SET THE
'MODE FOR EVERY MONITOR/ADAPTER COMBINATION, NOR IS THERE EVEN ANY 100%
'RELIABLE WAY TO DETECT THE CURRENT MODE. YOU MAY BE ABLE TO PEEK THE
'BIOS VIDEO STATUS WORD AT &H0040:&H0065, BIT 5, TO DETECT IT IN MOST
'CASES; THE BIT SHOULD BE SET WHEN BLINKING IS ENABLED, OFF WHEN
'HIGH -INTENSITY COLORS ARE AVAILABLE INSTEAD.
'
'Or better yet, use one of the many good add-on libraries available to
'Quick Basic programmers (such as PBCLONE, the Cadillac of the bunch)
'to detect and/or set the mode. There are also many PD routines, usually
'in Assembler form, available to accomplish this function.
'
'***************************************************************************
'***************************************************************************
'***************************************************************************
'
'To use this routine in your program, include the following DECLARE
'statement at the beginning of the main module of your program:
'
'DECLARE SUB QBCLRSEL (Title1$, Title2$, InitFClr%, InitBClr%,_
' BlinkSel%, CValsOn%, fc%, bc%, Attr%)
'
'In your program, call the routine with the following statement:
'
'QBCLRSEL Title1$, Title2$, InitFClr%, InitBClr%, BlinkSel%, CValsOn%,_
' fc%, bc%, Attr%
'
'See the demo code below for an example.
'
'***************************************************************************
'Inputs passed to the routine:
'***************************************************************************
'
' Title1$ This is a string of up to 78 characters which
' will be displayed, centered on the top screen
' line, as a title for the color selection process.
' If the string passed is empty (""), then a default
' title "Select Your Desired Color" will be used; if
' the string passed is "NOTITLE", then the top line
' will not be displayed. The colors for this line
' are fixed.
'
' Title2$ This is a string of up to 78 characters which
' will be displayed, centered on the second screen
' line, as a subtitle for the color selection process.
' If the string passed is empty (""), then a default
' title "Current Color Selection" will be used; if
' the string passed is "NOSUBTITLE", then this line
' will not be displayed. The colors for this line
' will change to the current color selection indicated
' as the user moves around the selection window.
'
' InitFClr% An integer value, ranging from 0 to 31, designating
' the initial, or default, foreground color. The color
' selection routine will begin with this value framed
' for selection; pressing ESCAPE at any time will return
' the current color selection to this value. Values
' from 0-15 are normal; values of 16-31 set blinking
' colors.
'
' InitBClr% An integer value, ranging from 0 to 7, designating
' the initial, or default, background color. The color
' selection routine will begin with this value framed
' for selection; pressing ESCAPE at any time will return
' the current color selection to this value.
'
' BlinkSel% Switch to enable/disable selection of blinking
' foreground colors. Any non-zero integer value
' will enable Blinking selection. Default mode is
' no blink selection. When blink selection is disabled,
' the corresponding blinking color status display
' is suppressed.
'
' CValsOn% Switch to enable/disable display of the current
' foreground and background color value numbers on
' the color status line of the screen. Any non-zero
' integer value will enable status display. Default
' mode is no color value display. When value display
' is disabled, the corresponding color value status
' display is suppressed.
'
'
'***************************************************************************
'Outputs from the routine:
'***************************************************************************
'
'
' fc% An integer value from 0-31 for the foreground color
' selected by the user. Values from 16-31 are blinking
' modes of the corresponding 0-15 values.
'
' bc% An integer value from 0-7 for the background color
' selected by the user.
'
' Attr% An integer value for the screen color attribute of
' the foreground/background color combination selected.
'
'
'***************************************************************************
'
'During the color selection process, the bottom line of the screen will
'display user help information, indicating the keys available for moving
'the selection frame. The ESCAPE key will be displayed, in the default
'color combination if visible (i.e. FG <> BG), as the key to return to
'default values; the ENTER key will always be displayed as the key for
'selection of a color combination. In the Blinking color selection
'routine, the Page Up key will be indicated to return to the color
'selection routine at the color combination currently displayed.
'
'
'***************************************************************************
'***************************************************************************
'***************************************************************************
'
'A (very simple) Demo for QBCLRSEL subroutine -- one subroutine call
'does it all!
'
'You can run this source code file from the QB environment, or run the
'stand-alone .EXE file included with this file.
'
DECLARE SUB QBCLRSEL (Title1$, Title2$, InitFClr%, InitBClr%, BlinkSel%, CValsOn%, fc%, bc%, Attr%)
DEFINT A-Z
'we will start with blink selection and color value displays enabled
BlinkSel = 1 'switch allows selecting blinking colors
CValsOn = 1 'switch allows display of color values
InitFClr = 10 'set initial color selection
InitBClr = 4
Title1$ = " QBCLRSEL Color Selection Demo " 'or whatever
Title2$ = " Screen Text Colors " 'ditto
begin:
QBCLRSEL Title1$, Title2$, InitFClr%, InitBClr%, BlinkSel%, CValsOn%, fc%, bc%, Attr%
'
'That's all it takes to get the color selection, the rest of this demo
'is just window dressing!
'
'
CLS 'display the colors selected
COLOR fc, bc
PRINT " Color Selection is: Foreground "; fc; " Background "; bc;
PRINT " Attribute "; Attr
PRINT
PRINT "Press a key..."
SLEEP
COLOR 7, 0
CLS
PRINT
INPUT "Make Another Color Selection"; AC$
IF UCASE$(AC$) = "Y" THEN 'if yes, make the next set of
IF fc > 15 THEN 'default colors be the colors
InitFClr = fc - 16 'selected this time, but
ELSE 'we must subtract the blinking
InitFClr = fc 'part of the foreground value
END IF
InitBClr = bc
INPUT "Activate Blink Selection"; AB$
IF UCASE$(AB$) = "Y" THEN 'activate blink selection
BlinkSel = 1
ELSE
BlinkSel = 0
END IF
INPUT "Activate Color Value Display"; CVD$
IF UCASE$(CVD$) = "Y" THEN 'activate color values
CValsOn = 1
ELSE
CValsOn = 0
END IF
GOTO begin 'play it again, Sam
END IF
END 'of another awesome demonstration of modern computing power
SUB QBCLRSEL (Title1$, Title2$, InitFClr%, InitBClr%, BlinkSel%, CValsOn%, fc%, bc%, Attr%)
'***************************************************************************
'QUICK BASIC COLOR SELECT SUBROUTINE
'***************************************************************************
'
'
DEFINT A-Z 'default to integers for all variables
SCREEN 0
IF Title1$ = "" THEN 'if a title string is not
Title1$ = " Select Your Desired Color " 'passed to the routine, this
ELSEIF Title1$ = "NOTITLE" THEN 'sets defaults
Title1$ = ""
END IF
IF Title2$ = "" THEN 'ditto for subtitle
Title2$ = " Current Color Selection "
ELSEIF Title2$ = "NOSUBTITLE" THEN
Title2$ = ""
END IF
MaxRows% = 7 '8 Background Colors
MaxCols% = 15 '16 Foreground Colors
REDIM RowVal(MaxRows%) 'initialize frame location arrays
REDIM ColumnVal(MaxCols%) 'as dynamic arrays
COLOR 7, 0 'set color to clear screen
CLS 'to black background
IF LEN(Title1$) THEN
IF LEN(Title1$) < 79 THEN 'set location for Title
T1loc = (79 - (LEN(Title1$))) / 2 'and center it
ELSE
Title1$ = LEFT$(Title1$, 78) 'truncate if longer than
T1loc = 1 '78 characters
END IF
END IF
IF LEN(Title2$) THEN
IF LEN(Title2$) < 79 THEN 'set location for subtitle
T2loc = (79 - (LEN(Title2$))) / 2 'same way
ELSE
Title2$ = LEFT$(Title2$, 78)
T2loc = 1
END IF
END IF
IF BlinkSel THEN 'set starting column location of the sample
stloc = 9 'text string display, at left if both
ELSEIF CValsOn THEN 'blink and value displays enabled, further
stloc = 20 'right if just values enabled, centered
ELSE 'if neither enabled
stloc = 31
END IF
FOR y = 0 TO 7 'get and store selection frame location array
RowVal(y) = 4 + (y * 2) 'values for rows
NEXT
FOR x = 0 TO 15 'and columns
ColumnVal(x) = 6 + (x * 4)
NEXT
FOR bg = 0 TO 7 'build and display color selection chart
CurRow = RowVal(bg) + 1
FOR fg = 0 TO 15
CurColumn = ColumnVal(fg) + 1
LOCATE CurRow, CurColumn
COLOR fg, bg: PRINT "Txt";
NEXT fg
NEXT bg
IF LEN(Title1$) THEN 'if a title is passed,
COLOR 4, 3 'print the title
LOCATE 1, T1loc
PRINT Title1$
END IF
COLOR 7, 0 'display selection window around
'first color selection
'make our selection window frame
tl$ = CHR$(213) 'frame characters ╒
tm$ = CHR$(205) ' ═
tr$ = CHR$(184) ' ╕
bm$ = CHR$(205)
bl$ = CHR$(212) ' ╘
br$ = CHR$(190) ' ╛
ml$ = CHR$(179) ' │
mr$ = CHR$(179) '
'assemble the strings
'for color selection cell frame
tlin$ = tl$ + tm$ + tm$ + tm$ + tr$ 'top line of frame
blin$ = bl$ + bm$ + bm$ + bm$ + br$ 'bottom line of frame
'assemble the strings
'for standard/blink selection frame
tmblnk$ = "" 'erase any previous strings
bmblnk$ = ""
FOR j = 1 TO 19
tmblnk$ = tmblnk$ + tm$ 'top line of frame
bmblnk$ = bmblnk$ + bm$ 'bottom line of frame
NEXT
tlinblnk$ = tl$ + tmblnk$ + tr$ 'add corners to frame lines
blinblnk$ = bl$ + bmblnk$ + br$
tlclr$ = " " 'erase strings for color selection frame
blclr$ = " "
tlbclr$ = SPACE$(21) 'erase strings for standard/blink
blbclr$ = SPACE$(21) 'selection frame
'initialize help line strings
Row24CS$ = " Crsr Up Dn Rt Lt PgUp PgDn Tab ShTab Home End "
Row24BS$ = " Crsr Rt Lt Tab ShTab "
DoClrSelect: 'start the color selection routine
fc = InitFClr 'set initial color for foreground color
bc = InitBClr 'set initial color for background color
DoSelectAgain: 're-entry point from blink select
'locate frame at first selection
pr = RowVal(bc) 'print row at location passed to routine
pc = ColumnVal(fc) 'print column same way
COLOR 10, 0 'print sample color bar line
LOCATE 22, stloc - 2
PRINT "> <"; 'bracket the standard text display
IF BlinkSel THEN 'and the blinking text, if enabled
LOCATE 22, 51
PRINT "> <"
END IF
IF CValsOn THEN 'if color value display enable switch
LOCATE 22, stloc + 20 'is set, then print display legends
PRINT "Fgnd:";
LOCATE 22, stloc + 31
PRINT "Bgnd:";
END IF
HelpLine$ = Row24CS$ 'display help line
Row24X$ = "" 'no PgUp prompt
GOSUB helplin
GOSUB samplin 'print color sample text display
GOSUB valprnt 'print current color values if switch enabled
DO 'loop for selecting color
LOCATE pr, pc 'print the frame--
PRINT tlin$; 'top line
LOCATE pr + 1, pc
PRINT ml$; 'middle left
LOCATE , pc + 4
PRINT mr$; 'middle right
LOCATE pr + 2, pc
PRINT blin$; 'bottom line
GOSUB keyget 'get key pressed
'returns value kp, ASC code of key pressed
IF kp <> 13 THEN 'if not ENTER key, then we are going to
GOSUB erasfrm 'move the frame, so we can erase the frame
END IF 'in the current location
SELECT CASE kp 'find out which key was pressed
'and adjust frame location parameters pr,pc
'if keypress was ENTER, this section
'does nothing
CASE 77 'right arrow
IF pc < 66 THEN 'if not at end of row
pc = pc + 4 'go to next column location in the row
fc = fc + 1 'which increments foreground color value
ELSE
pc = 6 'else go back to beginning of row
fc = 0
END IF
CASE 75 'left arrow
IF pc > 6 THEN 'opposite way way for other direction arrow
pc = pc - 4
fc = fc - 1
ELSE
pc = 66
fc = 15
END IF
CASE 72 'up arrow
IF pr > 4 THEN 'same as above, only up and down
pr = pr - 2 'changing background colors
bc = bc - 1
ELSE
pr = 18
bc = 7
END IF
CASE 80 'down arrow
IF pr < 18 THEN
pr = pr + 2
bc = bc + 1
ELSE
pr = 4
bc = 0
END IF
CASE 71 'home
pr = 4: pc = 6 'back to first cell
fc = 0: bc = 0 'black on black
CASE 79 'end
pr = 18: pc = 66 'go to last cell
fc = 15: bc = 7
CASE 9 'right tab
pc = 66 'go to end of current row
fc = 15
CASE 15 'shift tab
pc = 6 'go to beginning of current row
fc = 0
CASE 73 'page up
pr = 4 'go to top of current column
bc = 0
CASE 81 'page down
pr = 18 'go to bottom of current column
bc = 7
CASE 27 'esc returns to initial color values
pr = RowVal(InitBClr) 'print row at location
'passed to routine
pc = ColumnVal(InitFClr) 'print column same way
fc = InitFClr 'set initial color
'for foreground color
bc = InitBClr 'set initial color
'for background color
END SELECT
'now we have our keypress
GOSUB samplin 'update text sample line
GOSUB valprnt 'print color values if switch enabled
LOOP UNTIL kp = 13 'do it again, until ENTER key pressed
'*********************************************************************
'blink/non-blink color selection
GOSUB erasfrm 'ENTER key selected, erase color
'select frame
'if blink selection enabled,
'print the standard/blink selection frame
IF BlinkSel THEN 'select standard/blink characters
'if switch is set
Oldfc = fc 'store the selected colors
Oldbc = bc 'in case we start over
pr = 21: pc = 6: kp = 0 'initial selection frame on standard
DO 'loop to select
LOCATE pr, pc 'print standard/blink selection frame
PRINT tlinblnk$;
LOCATE pr + 1, pc
PRINT ml$;
LOCATE , pc + 20
PRINT mr$;
LOCATE pr + 2, pc
PRINT blinblnk$;
HelpLine$ = Row24BS$ 'print the standard/blink help line
Row24X$ = " PgUp " 'add Page Up key to return to color
GOSUB helplin 'selection with current colors as defaults
GOSUB keyget 'get user keypress
IF kp <> 13 THEN 'if not ENTER key, then we are
GOSUB erasfrmblnk 'going to move the frame
END IF 'so we can erase the frame
'in the current location
'find out which key was pressed
'and adjust frame location parameters pr,pc
SELECT CASE kp 'only allow right/left cursor, ESC,
'tab keys, page up, and ENTER
CASE IS = 77, 9 'right arrow or right tab
IF pc < 50 THEN 'same general way as above
pc = 50
fc = fc + 16
ELSE
pc = 6
fc = fc - 16
END IF
CASE IS = 75, 15 'left arrow or shift tab
IF pc > 6 THEN
pc = 6
fc = fc - 16
ELSE
pc = 50
fc = fc + 16
END IF
CASE IS = 27 'ESCape key
GOTO DoClrSelect 'start over from beginning
CASE IS = 73 'Page up key
fc = Oldfc
bc = Oldbc
GOTO DoSelectAgain 'go back to choose another color
END SELECT
GOSUB valprnt 'update the current color value display
LOOP UNTIL kp = 13 'if not ENTER key, do it again
END IF 'all of this loop is skipped if blink
'selection was not enabled
'*********************************************************************
'At this point we are done selecting the color combination
Attr = (bc * 16) + fc 'determine attribute for selected
'color combination
'and we are done with the subroutine
GOTO Done 'Beam us up, Scotty
'**************************************************************************
'**************************************************************************
'Local subroutines used in color selection program.
'Yes, that's right -- GOSUBs will be used in YOUR perfectly-coded program!!
'Who cares? It works -- PB
'**************************************************************************
'**************************************************************************
'
'
'**************************************************************************
'local subroutine to erase current frame by printing spaces over the
'current frame display
'**************************************************************************
erasfrm:
LOCATE pr, pc: PRINT tlclr$;
LOCATE pr + 1, pc: PRINT " "; : LOCATE , pc + 4: PRINT " ";
LOCATE pr + 2, pc: PRINT blclr$;
RETURN
'**************************************************************************
'local subroutine prints current color values in display boxes in line 22
'**************************************************************************
valprnt:
IF CValsOn THEN 'converts color values to
'printable strings
ft$ = " " + LTRIM$(RTRIM$(STR$(fc)))
bt$ = " " + LTRIM$(RTRIM$(STR$(bc)))
COLOR 7, 0 'first print the backgrounds
LOCATE 22, stloc + 26 'to erase any old values
PRINT " ";
LOCATE 22, stloc + 37
PRINT " ";
COLOR 1, 7 'then print the values
LOCATE 22, stloc + 26
PRINT ft$;
LOCATE 22, stloc + 37
PRINT bt$;
END IF
COLOR 7, 0 'restore black background
RETURN
'**************************************************************************
'local subroutine to get next keypress and return value in kp
'**************************************************************************
keyget:
ks$ = "" 'clear out any old keypress code
DO 'get user keypress
ks$ = INKEY$
LOOP UNTIL ks$ > ""
ks$ = RIGHT$(ks$, 1) 'get keyscan code, less the ASC(0)
kp = ASC(ks$) 'if ctl/alt key combination
RETURN
'**************************************************************************
'local subroutine to erase current standard/blink frame
'**************************************************************************
erasfrmblnk:
COLOR 7, 0
LOCATE pr, pc: PRINT tlbclr$;
LOCATE pr + 1, pc: PRINT " "; : LOCATE , pc + 20: PRINT " ";
LOCATE pr + 2, pc: PRINT blbclr$;
RETURN
'**************************************************************************
'local subroutine to update sample line
'**************************************************************************
samplin:
COLOR fc, bc 'reprint subtitle in current colors
IF LEN(Title2$) THEN
LOCATE 3, T2loc
PRINT Title2$
END IF
LOCATE 22, stloc 'stloc = 9 for blink, 32 no blink
PRINT " Standard Text ";
IF BlinkSel THEN
LOCATE 22, 53
COLOR fc + 16, bc
PRINT " Blinking Text ";
END IF
RETURN
'**************************************************************************
'local subroutine to print help line
'**************************************************************************
helplin:
LOCATE 24, 4
COLOR 15, 5
PRINT HelpLine$; 'print available keys help message
IF LEN(Row24X$) THEN 'print PgUp if necessary
COLOR Oldfc, Oldbc
PRINT Row24X$;
END IF
IF InitFClr <> InitBClr THEN 'if default fg,bg colors are not equal
COLOR InitFClr, InitBClr 'then print ESC help message
ELSE 'in default colors
COLOR 0, 7 'else print in black on white
END IF
PRINT " Esc ";
COLOR 1, 2 'print ENTER help message
PRINT " ENTER Selects ";
COLOR 7, 0
RETURN
'**************************************************************************
'**************************************************************************
Done: 'Back to the Starship ENTERPRISE
END SUB